home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 August / Macworld (1997-08).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / htmlEngine.tcl < prev    next >
Encoding:
Text File  |  1997-06-17  |  47.8 KB  |  1,597 lines  |  [TEXT/ALFA]
  1. #===============================================================================
  2. #
  3. #     htmlEngine.tcl (called from html.tcl)
  4. #
  5. #    Part of HTML mode 1.4.1
  6. #
  7. #     General Support Routines
  8. #
  9. #    Copyright 1996, 1997 by Johan Linde <jl@theophys.kth.se>.
  10. #    This software may be used freely, and distributed freely, as long as 
  11. #    the receiver is not obligated in any way by receiving it.
  12. #
  13. #    If you make improvements to this file, please share them!
  14. #
  15. #===============================================================================
  16.  
  17.  
  18. proc htmlIsUnsignedInteger {str1} {
  19.     return [regexp {^[0-9]+$} [string trim $str1]]
  20. }
  21.  
  22. proc htmlIsPositiveInteger {str1} {
  23.     return [expr ([htmlIsUnsignedInteger $str1] && ![regexp {^0+$} [string trim $str1]])]
  24. }
  25.  
  26. proc htmlIsInteger {str} {
  27.     return [regexp {^-?[0-9]+$} [string trim $str]]
  28. }
  29.  
  30. # Checks to see if the current window is empty, except for whitespace.
  31. proc htmlIsEmptyFile {} {
  32.     return [htmlIsWhite [getText 0 [maxPos]]]
  33. }
  34.  
  35. # Quoting of strings for meta tags.
  36. proc htmlQuote {str} {
  37.     regsub -all "#" $str {#;} str
  38.     regsub -all "\"" $str {#qt;} str
  39.     regsub -all "<" $str {#lt;} str
  40.     regsub -all ">" $str {#gt;} str
  41.     return $str
  42. }
  43.  
  44. proc htmlUnQuote {str} {
  45.     regsub -all {#qt;} $str "\"" str
  46.     regsub -all {#lt;} $str "<" str
  47.     regsub -all {#gt;} $str ">" str
  48.     regsub -all {#;} $str "#" str
  49.     return $str
  50. }
  51.  
  52. proc htmlCommentStrings {} {
  53.     if {![catch {search -f 0 -r 1 -i 1 -m 0 {<SCRIPT([ \t\r]+[^>]*>|>)} [getPos]} res1] &&
  54.     ([catch {search -f 0 -r 1 -i 1 -m 0 {</SCRIPT>} [getPos]} res2] || 
  55.     [lindex $res1 0] > [lindex $res2 0])} {
  56.         return [list "/* " " */"]
  57.     } else {
  58.         return [list "<!-- " " -->"]
  59.     }
  60. }
  61.  
  62. # Create a string for URL mapping in Big Brother.
  63. proc htmlURLmap {} {
  64.     global HTMLmodeVars
  65.     set urlmap {}
  66.     foreach hp $HTMLmodeVars(homePages) {
  67.         set fld "[htmlURLescape [lindex $hp 0] 1]/"
  68.         regsub -all ":" $fld "/" fld
  69.         set url [htmlURLescape "[lindex $hp 1][lindex $hp 2]"]
  70.         lappend urlmap "Msta:“$url”, Mend:“file:///$fld”"
  71.         append urlmap ","
  72.     }
  73.     set urlmap [string trimright $urlmap ","]
  74.     return $urlmap
  75. }
  76.  
  77. # Escapes certain characters in URLs.
  78. proc htmlURLescape {str {slash 0}} {
  79.     set hexa {0 1 2 3 4 5 6 7 8 9 A B C D E F}
  80.     set nstr ""
  81.     set exp "\[\001- \177-ˇ%<>\"#\?=&;|\\{\\}\\`^"
  82.     if {$slash} {append exp "/"}
  83.     append exp "\]"
  84.     while {[regexp -indices $exp $str c]} {
  85.         set asc [htmlAscii [string index $str [lindex $c 0]]]
  86.         append nstr [string range $str 0 [expr [lindex $c 0] - 1]]
  87.         append nstr % [lindex $hexa [expr $asc / 16]] [lindex $hexa [expr $asc % 16]]        
  88.         set str [string range $str [expr [lindex $c 1] + 1] end]
  89.     }
  90.     return "$nstr$str"
  91. }
  92.  
  93. proc htmlURLescape2 {str} {
  94.     set url ""
  95.     regexp {[^#]*} $str url
  96.     set anchor [string range $str [string length $url] end]
  97.     return "[htmlURLescape $url]$anchor"
  98. }
  99.  
  100. # Translate escaped characters in URLs.
  101. proc htmlURLunEscape {str} {
  102.     set hexa {0 1 2 3 4 5 6 7 8 9 A B C D E F}
  103.     set nstr ""
  104.     while {[regexp -indices {%[0-9A-F][0-9A-F]} $str hex]} {
  105.         append nstr [string range $str 0 [expr [lindex $hex 0] - 1]]
  106.         append nstr [htmlAscii [expr 16 * [lsearch $hexa [string index $str [expr [lindex $hex 0] + 1]]] \
  107.         + [lsearch $hexa [string index $str [expr [lindex $hex 0] + 2]]]] 1]
  108.         set str [string range $str [expr [lindex $hex 1] + 1] end]
  109.     }
  110.     return "$nstr$str"
  111. }
  112.  
  113. # Makes a line for browser error window.
  114. proc htmlBrwsErr {fil l lnum ln text path} {
  115.     return "$fil[format "%$l\s" ""]; Line $lnum:[format "%$ln\s" ""]$text\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$path\r"
  116. }
  117.  
  118.  
  119. proc htmlIsTextFile {fil cmd} {
  120.     getFileInfo $fil filetest
  121.     if {$filetest(type) != "TEXT"} {
  122.         $cmd "[file tail $fil] is not a text file."
  123.         return 0
  124.     }
  125.     return 1
  126. }
  127.  
  128. proc htmlAllSaved {msg} {
  129.     set dirty 0
  130.     foreach w [winNames] {
  131.         getWinInfo -w $w arr
  132.         if {$arr(dirty)} {set dirty 1; break}
  133.     }
  134.     if {$dirty} {
  135.         set yn [eval [concat askyesno $msg]]
  136.         if {$yn == "yes"} {saveAll}
  137.         return $yn
  138.     }
  139.     return yes
  140. }
  141.  
  142. proc htmlIsThereAHomePage {} {
  143.     global HTMLmodeVars    
  144.     if {![llength $HTMLmodeVars(homePages)]} {
  145.         alertnote "You must set a home page folder."
  146.         htmlHomePages
  147.     }
  148.     return [llength $HTMLmodeVars(homePages)]
  149. }
  150.  
  151. proc htmlWhichHomePage {msg} {
  152.     global HTMLmodeVars
  153.     foreach hp $HTMLmodeVars(homePages) {
  154.         lappend hplist "[lindex $hp 1][lindex $hp 2]"
  155.     }
  156.     if {[catch {listpick -p "Select home page to $msg." $hplist} hp] || ![string length $hp]} {error ""}
  157.     set home [lindex $HTMLmodeVars(homePages) [lsearch -exact $hplist $hp]]
  158.     if {![file exists [lindex $home 0]] || ![file isdirectory [lindex $home 0]]} {
  159.         alertnote "Can't find the folder for [lindex $home 1][lindex $home 2]"
  160.         error ""
  161.     }
  162.     return $home
  163. }
  164.  
  165. # Checks if a folder contains a home page folder or an include folder as a subfolder.
  166. proc htmlContainHpFolder {folder} {
  167.     global HTMLmodeVars
  168.     foreach p $HTMLmodeVars(homePages) {
  169.         foreach i {0 4} {
  170.             if {[llength $p] == $i} {continue}
  171.             if {[string match "$folder:*" "[lindex $p $i]:"] && "[lindex $p $i]:" != "$folder:"} {
  172.                 return 1
  173.             }
  174.         }
  175.     }
  176.     return 0
  177. }
  178.  
  179. # Asks for a folder and checks that it is not an alias.
  180. proc htmlGetDir {prompt} {
  181.     while {1} {
  182.         if {[file isdirectory [set folder [get_directory -p $prompt]]]} {
  183.             break
  184.         } else {
  185.             alertnote "Sorry! Cannot resolve aliases."
  186.         }
  187.     }
  188.     return [string trimright $folder :]
  189. }
  190.  
  191. proc htmlAscii {char {num 0}} {
  192.     if {$char == ""} {return 0}
  193.     set str "\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017"
  194.     append str "\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
  195.     append str " !\"#\$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  196.     append str "\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177ÄÅÇÉÑÖÜáàâäãåçéèêë"
  197.     append str "íìîïñóòôöõúùûü†°¢£§•¶ß®©™´¨≠ÆØ∞±≤≥¥µ∂∑∏π∫ªºΩæø¿¡¬√ƒ≈Δ«»… ÀÃÕŒœ–—"
  198.     append str "“”‘’÷◊ÿŸ⁄€‹›fifl‡·‚„‰ÂÊÁËÈÍÎÏÌÓÔÒÚÛÙıˆ˜¯˘˙˚¸˝˛ˇ"
  199.     if {$num} {
  200.         return [string index $str [expr $char - 1]]
  201.     } else {
  202.         return [expr 1 + [string first $char $str]]
  203.     }
  204. }
  205.  
  206. proc htmlNotYet {} {
  207.     alertnote "Not yet, but coming soon."
  208. }
  209.  
  210. proc htmlDisabled {} {
  211.     alertnote "Disabled function!"
  212.     error "Disabled function!"
  213. }
  214.  
  215. proc htmlSetCase {elem} {
  216.     global HTMLmodeVars 
  217.     if {$HTMLmodeVars(useLowerCase)} { 
  218.         return [string tolower $elem] 
  219.     } else {
  220.         return [string toupper $elem] 
  221.     }
  222. }
  223.  
  224.  
  225. # Returns a list of all attributes used in any HTML element.
  226. proc htmlGetAllAttrs {} {
  227.     global htmlElemAttrOptional1 htmlElemAttrRequired1 htmlElemEventHandler1
  228.     
  229.     foreach elem [array names htmlElemAttrOptional1] {
  230.         if {[info exists htmlElemAttrRequired1($elem)]} {
  231.             append allHTMLattrs " " $htmlElemAttrRequired1($elem)
  232.         }
  233.         append allHTMLattrs " " $htmlElemAttrOptional1($elem)
  234.         if {[info exists htmlElemEventHandler1($elem)]} {
  235.             append allHTMLattrs " " [string toupper $htmlElemEventHandler1($elem)]
  236.         }
  237.     }
  238.     return $allHTMLattrs
  239. }
  240.  
  241.  
  242. # Snatch the current selection into htmlCurSel, set flag whether there is one
  243. proc htmlGetSel {} {
  244.     global htmlCurSel htmlIsSel
  245.     set htmlCurSel [string trim [getSelect]]
  246.     set htmlIsSel [string length $htmlCurSel]
  247. }
  248.  
  249. #===============================================================================
  250. #  File routines
  251. #===============================================================================
  252.  
  253.  
  254. # Determines width and height of a GIF file.
  255. proc htmlGIFWidthHeight {fil} {
  256.     if {[catch {open $fil r} fid]} {return}
  257.     seek $fid 6 start
  258.     set width [expr [htmlReadOne $fid] + 256 * [htmlAscii [read $fid 1]]]
  259.     set height [expr [htmlReadOne $fid] + 256 * [htmlAscii [read $fid 1]]]
  260.     close $fid
  261.     return [list $width $height]
  262. }
  263.  
  264. # Extracts width and height of a jpeg file.
  265. # Algorithm from the perl script 'wwwimagesize' by
  266. # Alex Knowles, alex@ed.ac.uk
  267. # Andrew Tong, werdna@ugcs.caltech.edu
  268. proc htmlJPEGWidthHeight {fil} {
  269.     if {[catch {open $fil r} fid]} {return}
  270.     if {[htmlAscii [read $fid 1]] != 255 || [htmlAscii [read $fid 1]] != 216} {return}
  271.     set ch ""
  272.     while {![eof $fid]} {
  273.         while {[htmlAscii $ch] != 255 && ![eof $fid]} {set ch [read $fid 1]}
  274.         while {[htmlAscii $ch] == 255 && ![eof $fid]} {set ch [read $fid 1]}
  275.         if {[set asc [htmlAscii $ch]] >= 192 && $asc <= 195} {
  276.             seek $fid 3 current
  277.             set height [expr 256 * [htmlAscii [read $fid 1]] + [htmlReadOne $fid]]
  278.             set width [expr 256 * [htmlAscii [read $fid 1]] + [htmlReadOne $fid]]
  279.             close $fid
  280.             return [list $width $height]
  281.         } else {
  282.             set ln [expr 256 * [htmlAscii [read $fid 1]] + [htmlAscii [read $fid 1]] - 2]
  283.             if {$ln < 0} {break}
  284.             seek $fid $ln current
  285.         }
  286.     }
  287.     close $fid
  288. }
  289.  
  290. # Reads one character from an image file.
  291. # For some mysterious reason 10 and 13 has to be swapped.
  292. proc htmlReadOne {fid} {
  293.     set c [htmlAscii [read $fid 1]]
  294.     if {$c == 13} {
  295.         set c 10
  296.     } elseif {$c == 10} {
  297.         set c 13
  298.     }
  299.     return $c
  300. }
  301.  
  302.  
  303. # Returns the URL to the current window.
  304. # Called with 0 if called from htmlGetFile.
  305. # Called with 1 if called from HTMLDblClick. (0 or 1 determines the error message.)
  306. proc htmlThisFilePath {errorMsg} {
  307.     global HTMLmodeVars
  308.     
  309.     set thisFile [stripNameCount [lindex [winNames -f] 0]]
  310.     
  311.     # Look for BASE element.
  312.     if {![catch {search -s -f 1 -r 1 -i 1 -m 0 {<BASE[ \t\r]+[^>]*>} 0} res] && \
  313.     [regexp -nocase {HREF=\"?([^ \t\r\">]+)} [getText [lindex $res 0] \
  314.     [lindex $res 1]] dum href]} {
  315.         if {[catch {htmlBASEpieces $href} basestr]} {
  316.             alertnote "Window contains invalid BASE element. Ignored."
  317.         } else {
  318.             return $basestr
  319.         }
  320.     }
  321.     
  322.     # Check if window is saved.
  323.     if {![file exists $thisFile]} {
  324.         if {$errorMsg} {
  325.             set etxt "You must save the window, otherwise it cannot be determined\
  326.             where the link is pointing."
  327.         } else {
  328.             set etxt "You must save the window. If you save, you will then be prompted\
  329.             for a file to link to."
  330.         }
  331.         if {[lindex [dialog -w 400 -h 100 -t $etxt 10 10 390 60  \
  332.         -b Save 20 70  85 90 \
  333.         -b Cancel 110 70 175 90] 1]} {
  334.             return
  335.         }
  336.         
  337.         if {![catch {saveAs "Untitled.html"}]} {
  338.             set thisFile [stripNameCount [lindex [winNames -f] 0]]
  339.         } else {
  340.             return 
  341.         }
  342.     }
  343.     return [htmlBASEfromPath $thisFile]
  344. }
  345.  
  346. # Returns URL to file.
  347. proc htmlBASEfromPath {path} {
  348.     global HTMLmodeVars
  349.     foreach p $HTMLmodeVars(homePages) {
  350.         if {(![set i 0] && [string match "[lindex $p $i]:*" "$path:"]) || 
  351.         ([llength $p] == 5 && [set i 4] && [string match "[lindex $p $i]:*" "$path:"])} {
  352.             set path [string range $path [expr [string length [lindex $p $i]] + 1] end]
  353.             regsub -all {:} $path {/} path
  354.             return [list [lindex $p 1] [lindex $p 2] $path [lindex $p 0] $i [lindex $p 4]]
  355.         }
  356.     }
  357.     regsub -all {:} $path {/} path
  358.     return [list "file:///" "" $path "" 0]
  359. }
  360.  
  361. # Splits a BASE URL in pieces.
  362. # NOTE! That this proc returns a shorter list than the proc above, is used in
  363. # HTMLDblClick to determine if the doc contains a BASE tag.
  364. proc htmlBASEpieces {href} {
  365.     if {[regexp -indices {://} $href css]} {
  366.         if {[set sl [string first / [string range $href [expr [lindex $css 1] + 1] end]]] >=0} {
  367.             set base [string range $href 0 [expr [lindex $css 1] + $sl + 1]]
  368.             set path [string range $href [expr [lindex $css 1] + $sl + 2] end]
  369.             set sl [string last / $path]
  370.             set epath [string range $path [expr $sl + 1] end]
  371.             set path [string range $path 0 $sl]
  372.         } else {
  373.             set base [string range $href 0 [lindex $css 1]]
  374.             set path ""
  375.             set epath [string range $href [expr [lindex $css 1] + 1] end]
  376.         }
  377.         return [list [htmlURLunEscape $base] [htmlURLunEscape $path] [htmlURLunEscape $epath] ""]
  378.     } else {
  379.         error "Invalid BASE."
  380.     }
  381. }
  382.  
  383.  
  384. # Returns toFile including relative path from fromFile.
  385. proc htmlRelativePath {fromFile toFile} {
  386.     # Remove trailing /file from fromFile
  387.     set fromFile [string range $fromFile 0 [expr [string last / $fromFile] - 1]]
  388.  
  389.     set fromdir [split $fromFile /]
  390.     set todir [split $toFile /]
  391.     
  392.     # Remove the common path.
  393.     set i 0
  394.     while {[llength $fromdir] > $i && [llength $todir] > $i \
  395.     && [lindex $fromdir $i] == [lindex $todir $i]} {
  396.         incr i
  397.     }
  398.  
  399.     # Insert ../
  400.     foreach f [lrange $fromdir $i end] {
  401.         append linkTo "../"
  402.     }
  403.     # Add the path.
  404.     append linkTo [join [lrange $todir $i end] /]
  405.     
  406.     return $linkTo
  407. }
  408.  
  409.  
  410. # Returns a list of all HTML files in a folder and its subfolders.
  411. proc htmlAllHTMLfiles {folder} {
  412.     message "Building file list…"
  413.     set folders [list $folder]
  414.     while {[llength $folders]} {
  415.         set newFolders ""
  416.         foreach fl $folders { 
  417.             append files " " [htmlGetHTMLfiles $fl]
  418.             # Get folders in this folder.
  419.             if {![catch {glob "$fl:*"} filelist]} {
  420.                 foreach fil $filelist {
  421.                     if {[file isdirectory $fil]} {
  422.                         lappend newFolders $fil
  423.                     }
  424.                 }
  425.             }
  426.         }
  427.         set folders $newFolders
  428.     }
  429.     return $files
  430. }
  431.  
  432.  
  433. # Finds all HTML files in a folder
  434. proc htmlGetHTMLfiles {folder} {
  435.     global filepats
  436.     set files ""
  437.     if {![catch {glob -t TEXT $folder:*} filelist]} {
  438.         foreach fil $filelist {
  439.             foreach suffix $filepats(HTML) {
  440.                 if {[string match $suffix $fil]} {
  441.                     lappend files $fil
  442.                     break
  443.                 }
  444.             }
  445.         }
  446.     }
  447.     return $files
  448. }
  449.  
  450.  
  451. # checking = 1: called from htmlCheckLinks
  452. # Scan a list of files for HTML links and check if they point to existing files.
  453. # Some code is taken from grep.tcl
  454. # checking = 0: called from htmlMoveFiles
  455. # Build a list of links which point to the files just moved.
  456. proc htmlScanFiles {files baseURL basePath homepage isInFolder checking filebase {movedFiles ""}} {
  457.     global htmlURLAttr winModes HTMLmodeVars
  458.     global tileLeft tileTop tileWidth errorHeight
  459.     global htmlCaseFolders htmlCaseFiles
  460.  
  461.     set htmlCaseFolders ""; set htmlCaseFiles ""
  462.     set chCase $HTMLmodeVars(caseSensitive)
  463.     set chAnchor $HTMLmodeVars(checkAnchors)
  464.     
  465.     # Build regular expressions with URL attrs.
  466.     set exp "\[ \\t\\n\\r\]+("
  467.     foreach attr $htmlURLAttr {
  468.         append exp "$attr|"
  469.     }
  470.     set exp [string trimright $exp |]
  471.     append exp ")"
  472.  
  473.     
  474.     set expBase "<base\[ \\t\\n\\r\]+\[^>\]*>"
  475.     set expBase2 "(href=)\"?(\[^ \\t\\n\\r\">\]+)\"?"
  476. #     set exprr "$exp\"?(\[^ \\t\\n\\r\">\]+)\"?"
  477.     set exprr "${exp}(\"\[^\">\]+\"|\[^ \\t\\n\\r>\]+)"
  478.     set lines ""
  479.     set toModify ""
  480.  
  481.     foreach f $files {
  482.         if {[catch {set fid [open $f]}]} {continue}
  483.         set base $baseURL
  484.         set path $basePath
  485.         set hpPath $homepage
  486.         if {$isInFolder == ""} {
  487.             set epath $f
  488.         } else {
  489.             set epath [string range $f [expr [string length $isInFolder] + 1] end]
  490.         }
  491.         regsub -all {:} $epath {/} epath
  492.         set baseText ""
  493.         message "Looking at [file tail $f]…"
  494.         set filecont [read $fid]
  495.         close $fid
  496.         if {[regexp {\n} $filecont]} {
  497.             set newln "\n"
  498.         } else {
  499.             set newln "\r"
  500.         }
  501.         # Look for BASE.
  502.         if {[regexp -nocase $expBase $filecont thisLine]} {
  503.             if {[regexp -nocase $expBase2 $thisLine href b url]} {
  504.                 if {![catch {htmlBASEpieces $url} basestr]} {
  505.                     set base [lindex $basestr 0]
  506.                     set path [lindex $basestr 1]
  507.                     set epath [lindex $basestr 2]
  508.                     set hpPath ""
  509.                     set baseText "(BASE used) "
  510.                 } else {
  511.                     set baseText "(Invalid BASE) "
  512.                 }
  513.             }
  514.         }
  515.         set linenum 1
  516.         # Find all links in every line.
  517.         while {[regexp -nocase -indices $exprr $filecont href b url]} {
  518.             incr linenum [regsub -all $newln [string range $filecont 0 [lindex $url 0]] {} dummy]
  519.             set linkTo [htmlURLunEscape [string trim [string range $filecont [lindex $url 0] [lindex $url 1]] \"]]
  520.             set nogood 0
  521.             if {[catch {htmlPathToFile $base $path $epath $hpPath $linkTo} linkToPath]} {
  522.                 if {$linkToPath == ""} {
  523.                     set nogood 1
  524.                 }
  525.                 set linkToPath ""
  526.             } else {
  527.                 # Anchors always point to the file itself, unless there's a BASE. 
  528.                 if {[string index $linkTo 0] == "#" && $baseText == ""} {set linkToPath [list $f $f]}
  529.                 set casePath [lindex $linkToPath 1]
  530.                 set linkToPath [lindex $linkToPath 0]
  531.             }
  532.             # If this is BASE HREF, ignore it.
  533.             if {[string length $baseText] && [regexp -nocase -indices $expBase $filecont thisLine] \
  534.             && [regexp -nocase $expBase2 [string range $filecont [lindex $thisLine 0] [lindex $thisLine 1]]]\
  535.             && [lindex $thisLine 0] < [lindex $url 0] && [lindex $thisLine 1] > [lindex $url 1]} {
  536.                 set linkToPath ""
  537.             }
  538.             if {$checking} {
  539.                 set anchorCheck 1
  540.                 set caseOK 1
  541.                 set fext [file exists $linkToPath]
  542.                 if {$chAnchor && $linkToPath != "" && [regexp {#} $linkTo] && $fext} {set anchorCheck [htmlCheckAnchor $linkToPath $linkTo]}
  543.                 if {$chCase && $linkToPath != "" && $fext} {set caseOK [htmlCheckLinkCase $linkToPath $casePath]}
  544.                 # Does the file exist? Ignore it if it's outside home page folder.
  545.                 # Then it point to someone else's home page.
  546.                 if {!$anchorCheck || $nogood || !$caseOK || ( $linkToPath != "" && !$fext)} {
  547.                     set bText $baseText
  548.                     if {!$anchorCheck} {append bText "(anchor missing) "}
  549.                     if {!$caseOK} {append bText "(case doesn't match) "}
  550.                     if {$homepage == ""} {
  551.                         append lines [string range $f $filebase end]
  552.                     } else {
  553.                         append lines [string range $f [expr [string length $isInFolder] + 1] end]
  554.                     }
  555.                     set l [expr 20 - [string length [file tail $f]]]
  556.                     set ln [expr 5 - [string length $linenum]]
  557.                     set href [string trim [string range $filecont [lindex $href 0] [lindex $href 1]]]
  558.                     append lines "[format "%$l\s" ""]; Line $linenum:[format "%$ln\s" ""]$bText$href"\
  559.                     "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$f\r"
  560.                 }
  561.             } elseif {[lsearch -exact $movedFiles $linkToPath] >=0 } {
  562.                 set href [string trim [string range $filecont [lindex $href 0] [lindex $href 1]]]
  563.                 lappend toModify [list $f $linenum $base $path $epath $linkToPath $href]
  564.             }
  565.             set filecont [string range $filecont [lindex $url 1] end]
  566.         }
  567.     }
  568.  
  569.     unset htmlCaseFolders htmlCaseFiles
  570.     message ""
  571.     if {$checking} {
  572.         if {[string length $lines]} {
  573.             new -n "* Invalid URLs *" -g $tileLeft $tileTop $tileWidth $errorHeight
  574.             set name [lindex [winNames] 0]
  575.             changeMode [set winModes($name) Brws]
  576.             insertText "Incorrect links:  (<uparrow> and <downarrow> to browse, <return> to go to file)\r\r$lines"
  577.             select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]
  578.             setWinInfo dirty 0
  579.             setWinInfo read-only 1
  580.             scrollUpLine; scrollUpLine
  581.         } else {
  582.             alertnote "All links are OK."
  583.         }
  584.     } else {
  585.         return $toModify
  586.     }
  587. }
  588.  
  589.  
  590. # Determine the path to the file "linkTo", as linked from "base path epath". 
  591. proc htmlPathToFile {base path epath hpPath linkTo} {
  592.     global  HTMLmodeVars
  593.  
  594.     # Is this a mailto or news URL or anchor?
  595.     if {[string match "mailto:*" [string tolower $linkTo]] ||
  596.     [string match "news:*" [string tolower $linkTo]]} {
  597.         error $linkTo
  598.     }
  599.     
  600.     # remove /file from epath
  601.     set sl [string last / $epath]
  602.     set efil [string range $epath [expr $sl + 1] end]
  603.     set epath [string range $epath 0 $sl]
  604.  
  605.     # anchor points to efil
  606.     if {[string index $linkTo 0] == "#"} {set linkTo $efil}
  607.     
  608.     # Remove anchor from "linkTo".
  609.     regexp {[^#]*} $linkTo linkTo
  610.     
  611.     # Remove ./ from path
  612.     if {[string range $linkTo 0 1] == "./"} {set linkTo [string range $linkTo 2 end]}
  613.     
  614.     # Relative URL beginning with / is relative to server URL.
  615.     if {[string index $linkTo 0] == "/"} {
  616.         set linkTo "$base[string range $linkTo 1 end]"
  617.     }
  618.     
  619.     # Relative URL?
  620.     if {![regexp  {://} $linkTo]} {
  621.         set fromPath [split [string trimright "${path}$epath" /] /]
  622.         set toPath [split $linkTo /]
  623.         # Back down for every ../
  624.         set i 0
  625.         foreach tp $toPath {
  626.             if {$tp == ".."} {
  627.                 incr i
  628.             } else {
  629.                 break
  630.             }
  631.         }
  632.         if {$i > [llength $fromPath] } {
  633.             error ""
  634.         } else {
  635.             set path1 [join [lrange $fromPath 0 [expr [llength $fromPath] - $i - 1]] /]
  636.             if {[string length $path1]} {append path1 /}
  637.             append path1 [join [lrange $toPath $i end] /]
  638.             if {[string match "$path*" $path1] && [string length $hpPath]} {
  639.                 set pathTo [string range $path1 [string length $path] end]
  640.                 regsub -all {/} $pathTo {:} pathTo
  641.                 set casePath $pathTo
  642.                 set pathTo "$hpPath:$pathTo"
  643.                 if {![file isdirectory $pathTo]} {return [list $pathTo $casePath]}
  644.             } elseif {$base == "file:///"} {
  645.                 regsub -all {/} $path1 {:} pathTo
  646.                 return [list $pathTo $pathTo]
  647.             }
  648.             set linkTo "$base$path1"
  649.         }
  650.     }
  651.  
  652.     foreach hp [concat $HTMLmodeVars(homePages) {{"" file:/// "" ""}}]  {
  653.         if {[string match "[lindex $hp 1][lindex $hp 2]*" $linkTo] ||
  654.         [string trimright "[lindex $hp 1][lindex $hp 2]" /] == $linkTo} {
  655.             set pathTo [string range $linkTo [string length "[lindex $hp 1][lindex $hp 2]"] end]
  656.             regsub -all {/} $pathTo {:} pathTo
  657.             set casePath $pathTo
  658.             set pathTo [string trimleft "[lindex $hp 0]:$pathTo" :]
  659.             # If link to folder, add default file.
  660.             if {[file isdirectory $pathTo]} {
  661.                 set pathTo [string trimright $pathTo :]
  662.                 append pathTo ":[lindex $hp 3]"
  663.                 set casePath [string trimright $casePath :]
  664.                 append casePath ":[lindex $hp 3]"
  665.             }        
  666.             return [list $pathTo [string trimleft $casePath :]]
  667.         }
  668.     }
  669.     error $linkTo
  670. }    
  671.  
  672.  
  673. proc htmlCheckAnchor {anchorFile url} {
  674.     regexp {[^#]*#(.*)} $url dum anchor
  675.     if {[catch {open $anchorFile r} fid]} {return 1}
  676.     set filecont [read $fid]
  677.     close $fid
  678.     set exp "<(\[Aa\]|\[mM\]\[aA\]\[pP\])\[ \t\r\n\]+\[^>\]*\[nN\]\[aA\]\[mM\]\[eE\]=\"?$anchor\"?(>|\[ \t\r\n\]+\[^>\]*>)"
  679.     return [regexp $exp $filecont]
  680. }
  681.  
  682. # Checks that the case in a link match the case in the path to file.
  683. proc htmlCheckLinkCase {path link} {
  684.     global htmlCaseFolders htmlCaseFiles
  685.     
  686.     set path [string trimright $path :]
  687.     set link [string trimright $link :]
  688.     if {[lsearch -exact $htmlCaseFiles $path] >= 0} {return 1}
  689.     set path [split $path :]
  690.     set plen [llength $path]
  691.     set llen [llength [split $link :]]
  692.     set j [expr $plen - $llen ? $plen - $llen - 1 : 0]
  693.     for {set i $j} {$i < $plen - 1} {incr i} {
  694.         set l [lindex $path [expr $i + 1]]
  695.         set psub [join [lrange $path 0 $i] :]
  696.         if {[lsearch -exact $htmlCaseFolders $psub] < 0} {
  697.             lappend htmlCaseFolders $psub
  698.             append htmlCaseFiles " " [glob -nocomplain "$psub:*"]
  699.         }
  700.         if {[lsearch -exact $htmlCaseFiles "$psub:$l"] < 0} {return 0}
  701.     }
  702.     return 1
  703. }
  704.  
  705. #
  706. # Carriage returns and tabs (much borrowed from latex.tcl)
  707. #
  708.  
  709. # A boolean function which takes any string and tests to see if
  710. # that string contains all whitespace characters.  Carriage returns 
  711. # are considered whitespace, as are spaces and tabs.
  712. proc htmlIsWhite {anyString} {
  713.     return [regexp {^[ \t\r]*$} $anyString]
  714. }
  715.  
  716. # Insert one or two carriage returns at the insertion point if any
  717. # character preceding the insertion point (on the same line)
  718. # is a non-whitespace character.
  719. proc htmlOpenCR {{extrablankline 0}} {
  720.     set end [getPos]
  721.     set start [lineStart $end]
  722.     set text [getText $start $end]
  723.     if {![htmlIsWhite $text]} {
  724.         set r "\r"
  725.         if {$extrablankline} {append r "\r"}
  726.         return $r
  727.     } elseif {$start > 0 } { 
  728.         set prevstart [lineStart [expr $start - 1 ]]
  729.         set text [getText $prevstart [expr $start - 1]]
  730.         if {![htmlIsWhite $text] && $extrablankline} {
  731.             return "\r"
  732.         } else { 
  733.             return
  734.         }
  735.     } else {
  736.         return
  737.     }
  738. }
  739.  
  740. # Insert a carriage return at the insertion point if any
  741. # character following the insertion point (on the same line)
  742. # is a non-whitespace character.
  743. proc htmlCloseCR {} {
  744.     set start [getPos]
  745.     if {![htmlIsWhite [getText $start [nextLineStart $start]]]} {
  746.         return "\r" 
  747.     } else {
  748.         return
  749.     }
  750. }
  751.  
  752. # Set up tab mark mechanism.
  753. proc htmlTabGoto {directionIndicator} {
  754.     set searchResult [search -s -n -f $directionIndicator -m 0 -i 1 -r 0 {•} [getPos]]
  755.     if {![llength $searchResult] || [lindex $searchResult 0] >= [maxPos]} {
  756.         beep
  757.         message "Tab mark not found."
  758.         return 0
  759.     } else {
  760.         goto [lindex $searchResult 0]
  761.         return 1
  762.     }
  763. }
  764.  
  765. proc htmlTabNext {} {
  766.     if {[htmlTabGoto 1]} {deleteChar}
  767. }
  768.  
  769. proc htmlTabPrev {} {
  770.     if {[htmlTabGoto 0]} {deleteChar}
  771. }
  772.  
  773. # Puts up a window with error text.
  774.  
  775. proc htmlErrorWindow {errHeader errText {cancelButton 0}} {
  776.     
  777.     set errbox "-t {$errHeader} 100 10 400 25"
  778.     set hpos 35
  779.     foreach err $errText {
  780.         lappend errbox -t $err 10 $hpos 400 [expr $hpos + 15]
  781.         incr hpos 20
  782.     }
  783.     if {$cancelButton} {
  784.         lappend errbox -b Cancel 105 [expr $hpos + 20 ] 170 [expr $hpos + 40 ]
  785.     }
  786.     
  787.     set val [eval [concat dialog -w 430 -h [expr $hpos + 50 ] \
  788.     -b OK 20 [expr $hpos + 20 ] 85 [expr $hpos + 40 ] $errbox]]
  789.     return [lindex $val 0]
  790. }
  791.  
  792.  
  793. #===============================================================================
  794. # Building tags, including element attributes
  795. #===============================================================================
  796.  
  797. # A couple of functions to get element variables from the right package.
  798. proc htmlGetSomeAttrs {item type num1 pkg} {
  799.     global htmlElem${type}$num1  htmlElem${type}3
  800.     if {[catch {set atts [set htmlElem${type}${pkg}($item)]}]} { 
  801.         if {$type == "AttrMore"} {
  802.             set atts 0
  803.         } else {
  804.             set atts {} 
  805.         }
  806.     }
  807.     return $atts
  808. }    
  809.  
  810. proc htmlGetRequired {item} {
  811.     global htmlPackageToUse
  812.     return [htmlGetSomeAttrs $item AttrRequired 1 $htmlPackageToUse]
  813. }
  814.  
  815. proc htmlGetOptional {item} {
  816.     global htmlPackageToUse
  817.     return [htmlGetSomeAttrs $item AttrOptional 1 $htmlPackageToUse]
  818. }
  819.  
  820. proc htmlGetNumber {item} {
  821.     global htmlPackageToUse
  822.     return [htmlGetSomeAttrs $item AttrNumber 1 $htmlPackageToUse]
  823. }
  824.  
  825.  
  826. proc htmlGetChoices {item} {
  827.     global htmlPackageToUse
  828.     return [htmlGetSomeAttrs $item AttrChoices 1 $htmlPackageToUse]
  829. }
  830.  
  831. proc htmlGetUsed {item} {
  832.     global htmlPackageToUse
  833.     if {$htmlPackageToUse == 1} {
  834.         set num ""
  835.     } else {
  836.         set num 3
  837.     }
  838.     return [htmlGetSomeAttrs $item AttrUsed "" $num]
  839. }
  840.  
  841. proc htmlGetAttrMore {item} {
  842.     global htmlPackageToUse
  843.     if {$htmlPackageToUse == 1} {
  844.         set num ""
  845.     } else {
  846.         set num 3
  847.     }
  848.     return [htmlGetSomeAttrs $item AttrMore "" $num]
  849. }
  850.  
  851. proc htmlOpenElem {elem {used ""} {pos -1}} {
  852.     global HTMLmodeVars 
  853.     if {$HTMLmodeVars(useBigWindows)} {
  854.         return [htmlOpenElemWindow $elem $used $pos]
  855.     } else {
  856.         return [htmlOpenElemLoop $elem $used $pos]
  857.     }
  858. }
  859.  
  860. # Opening or only tag of an element - include attributes
  861. # Big window with all attributes.
  862. # Return empty string if user clicks "Cancel".
  863.  
  864. proc htmlOpenElemWindow {elem used wrPos {values ""}} {
  865.     global HTMLmodeVars  htmlColorName htmlElemEventHandler1
  866.     global  htmluserColors basicColors htmlPackageToUse
  867.     global htmlURLAttr htmlColorAttr  htmlWindowAttr
  868.     global htmlSpecURL htmlSpecColor htmlSpecWindow htmlWrapPos
  869.     
  870.     set URLs $HTMLmodeVars(URLs)
  871.     set Windows $HTMLmodeVars(windows)
  872.     
  873. # put users colours first
  874.     set htmlColors [lsort [array names htmluserColors]]
  875.      append htmlColors " " $basicColors
  876.  
  877.     if {![string length $used]} {set used $elem}
  878.     set elem [string toupper $elem]
  879.     set used [string toupper $used]
  880.     
  881.     # get variables for the element
  882.     set reqatts [htmlGetRequired $used]
  883.     set numatts [htmlGetNumber $used]
  884.     set optatts [htmlGetOptional $used]
  885.     set choiceatts [htmlGetChoices $used]
  886.  
  887.     set allatts [concat $reqatts $optatts]
  888.  
  889.     # optionally include event handlers
  890.     if {$HTMLmodeVars(inclEventHandler) && $htmlPackageToUse == 1 && \
  891.     [info exists htmlElemEventHandler1($used)]} {
  892.         set eventatts $htmlElemEventHandler1($used)
  893.         append allatts " " $eventatts
  894.     } else {
  895.         set eventatts ""
  896.     }
  897.  
  898.     # if there are attributes to ask about, do so
  899.  
  900.     set text "<"
  901.     append text  [htmlSetCase $elem] 
  902.     if {![llength $allatts]} {return "$text>"}
  903.  
  904.     set maxHeight [expr [lindex [getMainDevice] 3] - 115]
  905.     set thisPage "Page 1"
  906.  
  907.     
  908.     # build window with attributes 
  909.     set invalidInput 1
  910.     while {$invalidInput} {
  911.         # wrapping
  912.         set htmlWrapPos [expr $wrPos == -1 ? [lindex [posToRowCol [getPos]] 1] : $wrPos]
  913.         incr htmlWrapPos [expr [string length $text] + 1]
  914.         while {1} {
  915.             if {$used == "LI IN UL" || $used == "LI IN OL"} {
  916.                 set pr LI
  917.             } else {
  918.                 set pr $used
  919.             }
  920.             set box1 "-t {Attributes for $pr} 120 10 450 25"
  921.             set box2 "-t {Attributes for $pr} 120 10 450 25"
  922.             set box3 "-t {Attributes for $pr} 120 10 450 25"
  923.             set page 1
  924.             set attrtypes {}
  925.             set fileIndex ""
  926.             set colorIndex ""
  927.             set wpos 10
  928.             if {[string length $reqatts]} {
  929.                 lappend box$page -p 120 30 270 31 -t {Required attributes} 10 35 200 50
  930.                 set hpos 60
  931.             } else {
  932.                 set hpos 30
  933.             }
  934.             set attrIndex 2
  935.             for {set i 0} {$i < [llength $allatts]} {incr i} {
  936.                 set attr [lindex $allatts $i]
  937.                 if {$i == [llength $reqatts]} {
  938.                     if {$wpos > 20} { incr hpos 20 }
  939.                     lappend box$page -p 120 $hpos 270 [expr $hpos + 1] \
  940.                     -t {Optional attributes} 10 [expr $hpos + 5] 200 [expr $hpos + 20]
  941.                     set wpos 10
  942.                     incr hpos 30
  943.                 }
  944.                 set a2 [string trimright $attr =]
  945.                 if {[string index $attr [expr [string length $attr] - 1]] != "="}  { 
  946.                     # Flag
  947.                     if {[expr $hpos + 20] > $maxHeight && $wpos < 20 && $page < 3} {
  948.                         incr page
  949.                         set hpos 40
  950.                     }
  951.                     if {[llength values]} {
  952.                         set ctxt [lindex $values $attrIndex]
  953.                         incr attrIndex 
  954.                     } else {
  955.                         set ctxt 0
  956.                     }
  957.                     lappend box$page -c $attr $ctxt $wpos $hpos [expr $wpos + 100] [expr $hpos + 15]
  958.                     if {$wpos > 20} { 
  959.                         incr hpos 25
  960.                         set wpos 10
  961.                     } else {
  962.                         set wpos 230
  963.                     }
  964.                     lappend attrtypes flag
  965.                 } elseif {([lsearch -exact $htmlURLAttr $attr] >= 0 && [lsearch -exact $htmlSpecURL "${used}!=$a2"] < 0) || \
  966.                 [lsearch -exact $htmlSpecURL "${used}=$a2"] >= 0} { 
  967.                     # URL
  968.                     if {$wpos > 20} { incr hpos 25 ; set wpos 10}
  969.                     if {[expr $hpos + 45] > $maxHeight && $page < 3} {
  970.                         incr page
  971.                         set hpos 40
  972.                     }
  973.                     if {[llength values]} {
  974.                         set etxt [lindex $values $attrIndex]
  975.                         set mtxt [lindex $values [expr $attrIndex + 1]]
  976.                         incr attrIndex 3 
  977.                     } else {
  978.                         set etxt ""
  979.                         set mtxt {No value}
  980.                     }
  981.                     lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] \
  982.                     -e $etxt 120 $hpos 450 [expr $hpos + 15] \
  983.                     -m [concat [list $mtxt {No value}] $URLs] \
  984.                     120 [expr $hpos + 25] 450 [expr $hpos + 35] \
  985.                     -b "File…" 10 [expr $hpos + 20] 70 [expr $hpos + 40]
  986.                     incr hpos 50
  987.                     lappend attrtypes url
  988.                     lappend fileIndex [expr $attrIndex - 1]
  989.                 } elseif {([lsearch -exact $htmlColorAttr $attr] >= 0 && [lsearch -exact $htmlSpecColor "${used}!=$a2"] < 0) || \
  990.                 [lsearch -exact $htmlSpecColor "${used}=$a2"] >= 0} { 
  991.                     # Color attribute
  992.                     if {$wpos > 20} { incr hpos 25 ; set wpos 10}                    
  993.                     if {[expr $hpos + 25] > $maxHeight && $page < 3} {
  994.                         incr page
  995.                         set hpos 40
  996.                     }
  997.                     if {[llength values]} {
  998.                         set etxt [lindex $values $attrIndex]
  999.                         set mtxt [lindex $values [expr $attrIndex + 1]]
  1000.                         incr attrIndex 3
  1001.                     } else {
  1002.                         set etxt ""
  1003.                         set mtxt {No value}
  1004.                     }
  1005.                     lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] \
  1006.                     -e $etxt 120 $hpos 190 [expr $hpos + 15] \
  1007.                     -m [concat [list $mtxt {No value}] $htmlColors] \
  1008.                     200 $hpos 340 [expr $hpos + 15] \
  1009.                     -b "New Color…" 350 $hpos 450 [expr $hpos + 20]
  1010.                     incr hpos 30
  1011.                     lappend attrtypes color
  1012.                     lappend colorIndex [expr $attrIndex - 1]
  1013.                 } elseif {([lsearch -exact $htmlWindowAttr $attr] >= 0 && [lsearch -exact $htmlSpecWindow "${used}!=$a2"] < 0) || \
  1014.                 [lsearch -exact $htmlSpecWindow "${used}=$a2"] >= 0} { 
  1015.                     # Window attribute
  1016.                     if {$wpos > 20} { incr hpos 25 ; set wpos 10}                    
  1017.                     if {[expr $hpos + 25] > $maxHeight && $page < 3} {
  1018.                         incr page
  1019.                         set hpos 40
  1020.                     }
  1021.                     if {[llength values]} {
  1022.                         set etxt [lindex $values $attrIndex]
  1023.                         set mtxt [lindex $values [expr $attrIndex + 1]]
  1024.                         incr attrIndex 2
  1025.                     } else {
  1026.                         set etxt ""
  1027.                         set mtxt {No value}
  1028.                     }
  1029.                     lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] \
  1030.                     -e $etxt 120 $hpos 240 [expr $hpos + 15] \
  1031.                     -m [concat [list $mtxt {No value}] \
  1032.                     [concat {_self _top _parent _blank} $Windows]] \
  1033.                     250 $hpos 440 [expr $hpos + 15]
  1034.                     incr hpos 30
  1035.                     lappend attrtypes window
  1036.                 } elseif {[lsearch $numatts "${attr}*"] >= 0} { 
  1037.                     # Number
  1038.                     if {[expr $hpos + 20] > $maxHeight && $wpos < 20 && $page < 3} {
  1039.                         incr page
  1040.                         set hpos 40
  1041.                     }
  1042.                     if {[llength values]} {
  1043.                         set etxt [lindex $values $attrIndex]
  1044.                         incr attrIndex 
  1045.                     } else {
  1046.                         set etxt ""
  1047.                     }
  1048.                     lappend box$page -t $attr $wpos $hpos [expr $wpos + 100] [expr $hpos + 15] \
  1049.                     -e $etxt [expr $wpos + 110] $hpos [expr $wpos + 150] [expr $hpos + 15]
  1050.                     if {$wpos > 20} { 
  1051.                         incr hpos 25
  1052.                         set wpos 10
  1053.                     } else {
  1054.                         set wpos 230
  1055.                     }
  1056.                     lappend attrtypes number
  1057.                 } elseif {[lsearch $choiceatts "${attr}*"] >= 0} { 
  1058.                     # Choices
  1059.                     if {[expr $hpos + 20] > $maxHeight && $wpos < 20 && $page < 3} {
  1060.                         incr page
  1061.                         set hpos 40
  1062.                     }
  1063.                     set matches {}
  1064.                     foreach w $choiceatts {
  1065.                         if {[string match "${attr}*" $w]} {
  1066.                             lappend matches  [string range $w [string length $attr] end]
  1067.                         }    
  1068.                     }
  1069.                     if {[llength values]} {
  1070.                         set mtxt [lindex $values $attrIndex]
  1071.                         incr attrIndex 
  1072.                     } else {
  1073.                         set mtxt {No value}
  1074.                     }
  1075.                     lappend box$page -t $attr $wpos $hpos [expr $wpos + 100] [expr $hpos + 15] \
  1076.                     -m [concat [list $mtxt {No value}] $matches] \
  1077.                     [expr $wpos + 110] $hpos [expr $wpos + 205] [expr $hpos + 15]
  1078.                     if {$wpos > 20} { 
  1079.                         incr hpos 25 
  1080.                         set wpos 10
  1081.                     } else {
  1082.                         set wpos 230
  1083.                     }    
  1084.                     lappend attrtypes choices
  1085.                 } else {
  1086.                     # Any other
  1087.                     if {$wpos > 20} { incr hpos 25 ; set wpos 10}                    
  1088.                     if {[expr $hpos + 20] > $maxHeight && $page < 3} {
  1089.                         incr page
  1090.                         set hpos 40
  1091.                     }
  1092.                     if {[llength values]} {
  1093.                         set etxt [lindex $values $attrIndex]
  1094.                         incr attrIndex
  1095.                     } else {
  1096.                         set etxt ""
  1097.                     }
  1098.                     lappend box$page -t $attr 10 $hpos 120 [expr $hpos + 15] \
  1099.                     -e $etxt 120 $hpos 450 [expr $hpos + 15] 
  1100.                     incr hpos 25
  1101.                     lappend attrtypes any
  1102.                 }
  1103.             }
  1104.             if {$wpos > 20} { incr hpos 25 }
  1105.             
  1106.             if {$page == 1} {
  1107.                 set box $box1
  1108.             } elseif {$page == 2} {
  1109.                 set hpos $maxHeight
  1110.                 set box " -m \{\{$thisPage\} \{Page 1\} \{Page 2\}\} 10 10 85 30 -n \{Page 1\} $box1 -n \{Page 2\} $box2"
  1111.             } elseif {$page == 3} {
  1112.                 set hpos $maxHeight
  1113.                 set box " -m \{\{$thisPage\} \{Page 1\} \{Page 2\} \{Page 3\}\} 10 10 85 30 -n \{Page 1\} $box1 -n \{Page 2\} $box2 -n \{Page 3\} $box3"
  1114.             }
  1115.             set values [eval [concat dialog -w 460 -h [expr $hpos + 50] \
  1116.             -b OK 20 [expr $hpos + 20]  85 [expr $hpos + 40] \
  1117.             -b Cancel 110 [expr $hpos + 20] 175 [expr $hpos + 40] $box]]
  1118.             # If two pages...
  1119.             if {$page > 1} {
  1120.                 set thisPage [lindex $values 2]
  1121.                 set values [lreplace $values 2 2]
  1122.             }
  1123.             
  1124.             # OK button clicked?
  1125.             if {[lindex $values 0] } { break }
  1126.             # Cancel button clicked?
  1127.             if {[lindex $values 1] } { return}
  1128.             # File button clicked?
  1129.             foreach fl $fileIndex {
  1130.                 if {[lindex $values $fl]} {
  1131.                     set newFile [htmlGetFile]
  1132.                     if {[string length $newFile]} {
  1133.                         set URLs $HTMLmodeVars(URLs)
  1134.                         set values [lreplace $values [expr $fl - 1] [expr $fl - 1] [lindex $newFile 0]]
  1135.                         if {$used == "IMG" && $fl == 4 && [llength [set widhei [lindex $newFile 1]]]} {
  1136.                             set nnn [expr $htmlPackageToUse == 1 ? 8 : 5]
  1137.                             set values [lreplace $values $nnn $nnn [lindex $widhei 0]]
  1138.                             set values [lreplace $values [expr $nnn + 1] [expr $nnn + 1] [lindex $widhei 1]]
  1139.                         }
  1140.                     }
  1141.                 }
  1142.             }
  1143.             # Color button clicked?
  1144.             foreach cl $colorIndex {
  1145.                 if {[lindex $values $cl]} {
  1146.                     set newcolor [htmlAddNewColor]
  1147.                     if {[string length $newcolor]} { 
  1148.                         set htmlColors [concat [list $newcolor] $htmlColors]
  1149.                         set values [lreplace $values [expr $cl - 1] [expr $cl - 1] "$newcolor"]
  1150.                     }
  1151.                 }
  1152.             }
  1153.         }
  1154.         
  1155.         
  1156.         # put everything together
  1157.         set attrtext ""
  1158.         set errtext ""
  1159.         if {[lindex $values 0]} {
  1160.             set j 2
  1161.             for {set i 0} {$i < [llength $attrtypes]} {incr i} {
  1162.                 set attr [lindex $allatts $i]                
  1163.                 switch [lindex $attrtypes $i] {
  1164.                     url {
  1165.                         set texturl [string trim [lindex $values $j]]
  1166.                         set menuurl [lindex $values [expr $j + 1]]
  1167.                         if {[string length $texturl]} {        
  1168.                             append attrtext [htmlWrapTag "[htmlSetCase $attr][htmlAddQuotes [htmlURLescape2 $texturl]]"]
  1169.                             htmlAddToCache URLs $texturl
  1170.                         } elseif {$menuurl != "No value"} {
  1171.                             append attrtext [htmlWrapTag "[htmlSetCase $attr][htmlAddQuotes [htmlURLescape2 $menuurl]]"] 
  1172.                         } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1173.                             lappend errtext "$attr required."
  1174.                         }
  1175.                         incr j 3
  1176.                     }
  1177.                     color {
  1178.                         set colortxt [lindex $values $j]
  1179.                         set colorval [lindex $values [expr $j + 1]]
  1180.                         if {[string length $colortxt]} {
  1181.                             set col [htmlCheckColorNumber $colortxt]
  1182.                                  if {$col == 0} {
  1183.                                      lappend errtext "$attr: $colortxt is not a valid color number."
  1184.                             } else {    
  1185.                                 append attrtext [htmlWrapTag "[htmlSetCase $attr][htmlAddQuotes $col]"]
  1186.                             }
  1187.                         } elseif {$colorval != "No value"} {
  1188.                             # Users own color?
  1189.                             if {[info exists htmluserColors($colorval)]} {
  1190.                                 set colornum $htmluserColors($colorval)
  1191.                             }
  1192.                             # Predefined color?
  1193.                             if {[info exists htmlColorName($colorval)]} {
  1194.                                 set colornum $htmlColorName($colorval)
  1195.                             }
  1196.                             append attrtext [htmlWrapTag "[htmlSetCase $attr][htmlAddQuotes $colornum]"]
  1197.                         } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1198.                             lappend errtext "$attr required."
  1199.                         }
  1200.                         incr j 3
  1201.                     }
  1202.                     window {
  1203.                         set textwin [string trim [lindex $values $j]]
  1204.                         set menuwin [lindex $values [expr $j + 1]]
  1205.                         if {[string length $textwin]} {        
  1206.                             append attrtext [htmlWrapTag "[htmlSetCase $attr][htmlAddQuotes $textwin]"]
  1207.                             htmlAddToCache windows $textwin
  1208.                         } elseif {$menuwin != "No value"} {
  1209.                             append attrtext [htmlWrapTag "[htmlSetCase $attr][htmlAddQuotes $menuwin]"]
  1210.                         } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1211.                             lappend errtext "$attr required."
  1212.                         }
  1213.                         incr j 2
  1214.                     }
  1215.                     number {
  1216.                         set numval [string trim [lindex $values $j]]
  1217.                         if {[string length $numval]} {
  1218.                             if {[htmlCheckAttrNumber $used $attr $numval] == 1} {        
  1219.                                 append attrtext [htmlWrapTag "[htmlSetCase $attr][htmlAddQuotes $numval]"]
  1220.                             } else {
  1221.                                 lappend errtext "$attr: [htmlCheckAttrNumber $used $attr $numval]"
  1222.                             }
  1223.                         } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1224.                             lappend errtext "$attr required."
  1225.                         }
  1226.                         incr j
  1227.                     }
  1228.                     choices {
  1229.                         set choiceval [lindex $values $j]
  1230.                         if {$choiceval != "No value"} {        
  1231.                             set qchoice [htmlAddQuotes $choiceval]
  1232.                             if {($used != "LI IN OL" && $used != "OL") || $attr != "TYPE="} {
  1233.                                 set qchoice [htmlSetCase $qchoice]
  1234.                             }
  1235.                             append attrtext [htmlWrapTag "[htmlSetCase $attr]$qchoice"]
  1236.                         } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1237.                             lappend errtext "$attr required."
  1238.                         }
  1239.                         incr j
  1240.                     }
  1241.                     any {
  1242.                         set anyval [lindex $values $j]
  1243.                         # Trim only if it's only spaces.
  1244.                         if {[string trim $anyval] == ""} {set anyval ""}
  1245.                         if {[string length $anyval]} {
  1246.                             htmlOpenExtraThings $used $attr $anyval
  1247.                             if {[lsearch -exact $eventatts $attr] < 0} {
  1248.                                 set attr [htmlSetCase $attr]
  1249.                             }
  1250.                             append attrtext [htmlWrapTag "$attr[htmlAddQuotes $anyval]"]
  1251.                         } elseif {[lsearch -exact $reqatts $attr] >= 0} {
  1252.                             lappend errtext "$attr required."
  1253.                         }
  1254.                         incr j
  1255.                     }
  1256.                     flag {
  1257.                         set flagval [lindex $values $j]
  1258.                         if {$flagval} {        
  1259.                             append attrtext [htmlWrapTag [htmlSetCase $attr]]
  1260.                         }
  1261.                         incr j
  1262.                     }
  1263.                 }
  1264.             }
  1265.             # If everything is OK, add the attribute text to text.
  1266.             if {![llength $errtext]} {
  1267.                 append text $attrtext
  1268.                 set invalidInput 0
  1269.             } else {
  1270.                 # Put up alert with the error text.
  1271.                 htmlErrorWindow "Invalid input for $used" $errtext
  1272.             }
  1273.             # Some tests that input is ok.
  1274.             if {!$invalidInput} {set invalidInput [htmlFontBaseTest $text alertnote]}
  1275.             if {!$invalidInput && $elem == "A" && [set invalidInput [htmlATest $text alertnote]]} {
  1276.                 set text "<[htmlSetCase A]"
  1277.             }
  1278.             if {!$invalidInput && $elem == "FRAMESET" && [set invalidInput [htmlFramesetTest $text alertnote]]} {
  1279.                 set text "<[htmlSetCase FRAMESET]"
  1280.             }
  1281.             if {!$invalidInput && $elem == "SPACER" && [set invalidInput [htmlSpacerTest $text alertnote]]} {
  1282.                 set text "<[htmlSetCase SPACER]"
  1283.             }
  1284.             if {!$invalidInput && $elem == "AREA" && [set invalidInput [htmlAreaTest $text alertnote]]} {
  1285.                 set text "<[htmlSetCase AREA]"
  1286.             }
  1287.         } else {
  1288.             set text ""
  1289.         }    
  1290.     }
  1291.     
  1292.     if {[string length $text] } {append text ">"}
  1293.     
  1294.     return ${text}
  1295. }
  1296.  
  1297. proc htmlWrapTag {toadd} {
  1298.     global htmlWrapPos fillColumn HTMLmodeVars
  1299.     if {!$HTMLmodeVars(wordWrap)} {return " $toadd"}
  1300.     incr htmlWrapPos [string length $toadd]
  1301.     if {$htmlWrapPos > $fillColumn} {
  1302.         set htmlWrapPos [string length $toadd]
  1303.         return "\r$toadd"
  1304.     } else {
  1305.         return " $toadd"
  1306.     }
  1307. }
  1308.  
  1309. # these two require at least one of several optional attributes
  1310. proc htmlFontBaseTest {text cmd} {
  1311.     if {([string toupper $text] == "<FONT" || [string toupper $text] == "<BASE" )} {  
  1312.         eval {$cmd "At least one of the attributes is required."}
  1313.         return 1
  1314.     }
  1315.     return 0
  1316. }
  1317.  
  1318. # HREF or NAME must be used for A.
  1319. proc htmlATest {text cmd} {
  1320.     if {![regexp -nocase {href=} $text] && ![regexp -nocase {name=} $text]} {
  1321.         eval {$cmd "At least one of the attributes HREF and NAME must be used."}
  1322.         return 1
  1323.     }
  1324.     return 0
  1325. }
  1326.  
  1327. # ROWS or COLS must be used for FRAMESET
  1328. proc htmlFramesetTest {text cmd} {
  1329.     if {![regexp -nocase {rows=} $text] && ![regexp -nocase {cols=} $text]} {
  1330.         eval {$cmd "At least one of the attributes ROWS and COLS must be used."}
  1331.         return 1
  1332.     }
  1333.     return 0
  1334. }
  1335.  
  1336. # Some checks for SPACER.
  1337. proc htmlSpacerTest {text cmd} {
  1338.         set horver [regexp -nocase {type=\"(horizontal|vertical)\"} $text]
  1339.         set wh [regexp -nocase {width=|height=} $text]
  1340.         set sz [regexp -nocase {size=} $text]
  1341.         set al [regexp -nocase {align=} $text]
  1342.         set invalidInput 1
  1343.         if {$horver && ($wh || $al)} {
  1344.             eval {$cmd "WIDTH, HEIGHT and ALIGN should only be used when TYPE=BLOCK."}
  1345.         } elseif {!$horver && $sz} {
  1346.             eval {$cmd "SIZE should only be used when TYPE=HORIZONTAL or VERTICAL."}
  1347.         } elseif {$horver && !$sz} {
  1348.             eval {$cmd "SIZE is required when TYPE=HORIZONTAL or VERTICAL."}
  1349.         } elseif {!$horver && !$wh} {
  1350.             eval {$cmd "WIDTH or HEIGHT is required when TYPE=BLOCK."}
  1351.         } else {
  1352.             set invalidInput 0
  1353.         }
  1354.         return $invalidInput
  1355. }
  1356.  
  1357. # For AREA, either HREF or NOHREF must be used, but not both.
  1358. proc htmlAreaTest {text cmd} {
  1359.     set hasHref [regexp -nocase {href=} $text]
  1360.     set hasNohref [regexp -nocase {nohref} $text]
  1361.     set hasCoords [regexp -nocase {coords=} $text]
  1362.     set shapeDefault [regexp -nocase {shape=\"default\"} $text]
  1363.     set invalidInput 0
  1364.     if {($hasHref && $hasNohref) || (!$hasHref && !$hasNohref)} {
  1365.         eval {$cmd "One of the attributes HREF and NOHREF must be used, but not both."}
  1366.         set invalidInput 1
  1367.     } elseif {!$hasCoords && !$shapeDefault} {
  1368.         eval {$cmd "COORDS= is required if SHAPE≠DEFAULT"}
  1369.         set invalidInput 1
  1370.     }
  1371.     return $invalidInput
  1372. }
  1373.  
  1374. # Adds a NAME= value to cache.
  1375. proc htmlOpenExtraThings {elem attr val} {
  1376.     if {[lsearch -exact {A MAP} $elem] >= 0 && $attr == "NAME="} {
  1377.         htmlAddToCache URLs "#$val"
  1378.     }
  1379.     if {$elem == "FRAME" && $attr == "NAME="} {
  1380.         htmlAddToCache windows $val
  1381.     }
  1382. }
  1383.  
  1384.  
  1385. # Check if a color number is a valid number, or one of the predefined names.
  1386. # Returns 0 if not and the color number if it is.
  1387. proc htmlCheckColorNumber {color} {
  1388.     global htmlColorName
  1389.     set color [string tolower $color]
  1390.     if {[info exists htmlColorName($color)]} {return $htmlColorName($color)}
  1391.     if {[string index $color 0] != "#"} {
  1392.         set color "#${color}"
  1393.     }
  1394.     set color [string toupper $color]
  1395.     if {[string length $color] != 7 || ![regexp {^#[0-9A-F]+$} $color]} {
  1396.         return 0
  1397.     } else {
  1398.         return $color
  1399.     }    
  1400. }
  1401.  
  1402.  
  1403. # Adds a URL or window given as input to cache
  1404. proc htmlAddToCache {cache newurl} {
  1405.     global modifiedModeVars HTMLmodeVars
  1406.     
  1407.     if {$cache == "windows" && [lsearch -exact {_self _top _parent _blank} $newurl] >= 0} {return}
  1408.     set URLs $HTMLmodeVars($cache)
  1409.     
  1410.     if {[string length $newurl] && [lsearch -exact $URLs $newurl] < 0} { 
  1411.         set URLs [lsort [lappend URLs $newurl]]
  1412.         set HTMLmodeVars($cache) $URLs
  1413.         lappend modifiedModeVars [list $cache HTMLmodeVars]
  1414.         if {[llength $URLs] == 1} {htmlEnable$cache on}
  1415.     }
  1416. }
  1417.  
  1418. # Check if a input is a valid number for the element attribute.
  1419. # Returns 1 if it is, otherwise returns an error message.
  1420. proc htmlCheckAttrNumber {item attr number} {
  1421.     
  1422.     set attrNumbers [htmlGetNumber $item]
  1423.     set numind [lsearch $attrNumbers "${attr}*"]
  1424.     set numstr [string range [lindex $attrNumbers $numind] [string length $attr] end]
  1425.     regexp {^[-0-9]+} $numstr minvalue
  1426.     set numstr [string range $numstr [expr [string length $minvalue] + 1] end]
  1427.     regexp {^[-i0-9]+} $numstr maxvalue
  1428.     set procent [string range $numstr [expr [string length $numstr] - 1] end]
  1429.     if {$procent == "%"} {
  1430.         set procerr " or percentage"
  1431.     } else {
  1432.         set procerr ""
  1433.     }
  1434.     if {$maxvalue == "i"} {
  1435.         set errtext "A number $minvalue or greater"
  1436.     } else {
  1437.         set errtext "A number in the range $minvalue to $maxvalue"
  1438.     }
  1439.     if {$item == "FONT"} { append errtext " or -6 to +6"}
  1440.     append errtext  "$procerr expected." 
  1441.     # Is percent allowed?
  1442.     if {[string index $number [expr [string length $number] - 1]] == "%" } {
  1443.         set number [string range $number 0 [expr [string length $number] - 2]]
  1444.         if {$procent != "%"} {return $errtext}
  1445.     }
  1446.     # FONT can take values -6 - +6. Special case.
  1447.     if {$item == "FONT" && [regexp {^(\+|-)[1-6]$} $number]} { return 1}
  1448.     # Is input a number?
  1449.     if {![regexp {^-?[0-9]+$} $number]} {return $errtext}
  1450.     # Is input in the valid range?
  1451.     if {( $maxvalue != "i" && $number > $maxvalue ) || $number < $minvalue } {
  1452.         return $errtext
  1453.     }    
  1454.     return 1 
  1455. }
  1456.  
  1457.  
  1458. # Add quotes to attribute
  1459. proc htmlAddQuotes {v} {
  1460.  
  1461.     if {[string range $v 0 0] != "\""} {set v  "\"$v"}
  1462.      set vlen [expr [string length $v] - 1]
  1463.     if {[string range $v $vlen $vlen] !="\""} {append v "\""}
  1464.     return $v
  1465. }
  1466.  
  1467.  
  1468. # Splits an attribute into its name and value and remove quotes.
  1469. proc htmlRemoveQuotes {attrStr} {
  1470.     # Is it a flag?
  1471.     if {![string match "*=*" $attrStr]} {return [string toupper $attrStr]}
  1472.     
  1473.     set attr [string range $attrStr 0 [string first "=" $attrStr]]
  1474.     # Get the attribute value.
  1475.     set attrVal [string range $attrStr [expr [string first "=" $attrStr] + 1] end]
  1476.     
  1477.     return [list $attr [string trim $attrVal \"]]
  1478. }
  1479.  
  1480.  
  1481. # Closing tag of an element
  1482. proc htmlCloseElem {theElem} {
  1483.     return "</[htmlSetCase $theElem]>"
  1484. }
  1485.  
  1486.  
  1487. #
  1488. # Element build routines
  1489. #
  1490.  
  1491. # Build elements with only a opening tag.
  1492. proc htmlBuildOpening {ftype {begCR 0} {endCR 0} {attr ""}} {
  1493.     set text1 ""
  1494.     if {$begCR} { set text1 [htmlOpenCR]}
  1495.     set text [htmlOpenElem $ftype $attr]
  1496.     if {![string length $text]} {return}
  1497.     if {$endCR} {append text "\r"}
  1498.     insertText $text1 $text
  1499. }
  1500.  
  1501.     
  1502. # This is used for almost all containers
  1503. proc htmlBuildElem {ftype {attr ""}} {
  1504.     global HTMLmodeVars htmlCurSel htmlIsSel
  1505.  
  1506.     if {![string length [set text [htmlOpenElem $ftype $attr]]]} {return}
  1507.     htmlGetSel
  1508.     append text $htmlCurSel
  1509.     set currpos [expr [getPos] + [string length $text]]
  1510.     append text [htmlCloseElem $ftype]
  1511.     if {!$htmlIsSel && $HTMLmodeVars(useTabMarks)} {append text "•"}
  1512.     if {$htmlIsSel} {
  1513.         replaceText [getPos] [selEnd] $text
  1514.     } else {
  1515.         insertText $text
  1516.         goto $currpos
  1517.     }
  1518. }
  1519.  
  1520. # This is used for elements that should be surrounded by newlines
  1521. proc htmlBuildCRElem {ftype {extrablankline 0} {attr ""}} {
  1522.     global htmlCurSel htmlIsSel HTMLmodeVars
  1523.  
  1524.     set text [htmlOpenCR $extrablankline] 
  1525.     
  1526.     if {![string length [set text2 [htmlOpenElem $ftype $attr 0]]]} {return}
  1527.     append text $text2
  1528.     htmlGetSel
  1529.     append text $htmlCurSel
  1530.     set currpos [expr [getPos] + [string length $text]]
  1531.     append text [htmlCloseElem $ftype]
  1532.     append text "\r"
  1533.     if {$extrablankline} {append text "\r"}
  1534.     if {!$htmlIsSel && $HTMLmodeVars(useTabMarks)} {append text "•"}
  1535.     if {$htmlIsSel} { deleteSelection }
  1536.     insertText $text
  1537.     if {!$htmlIsSel}    {
  1538.         goto $currpos
  1539.     }
  1540. }
  1541.  
  1542. # This is used for elements that should be surrounded by empty lines
  1543. proc htmlBuildCR2Elem {ftype {attr ""}} {
  1544.     global HTMLmodeVars htmlCurSel htmlIsSel
  1545.     
  1546.     set text [htmlOpenCR 1] 
  1547. # Check if user has skipped an attribute which can't be skipped.
  1548.     if {![string length [set text2 [htmlOpenElem $ftype $attr 0]]]} {return}
  1549.     append text $text2
  1550.     htmlGetSel
  1551.     if {$htmlIsSel || $ftype != "SCRIPT"} {
  1552.         append text "\r$htmlCurSel"
  1553.     } else {
  1554.         append text "\r<!-- Hide content from old browsers\r"
  1555.     }
  1556.     set currpos [expr [getPos] + [string length $text]]
  1557.     append text "\r"
  1558.     if {!$htmlIsSel && $ftype == "SCRIPT"} {append text "// end hiding content from old browsers -->\r"}
  1559.     append text [htmlCloseElem $ftype]
  1560.     append text "\r\r"
  1561.     if {!$htmlIsSel && $HTMLmodeVars(useTabMarks)} {append text "•"}
  1562.     if {$htmlIsSel} { deleteSelection }
  1563.     insertText $text
  1564.     if {!$htmlIsSel}    {
  1565.         goto $currpos
  1566.     }
  1567. }
  1568.  
  1569. # Determines which list the current position is inside.
  1570. proc htmlFindList {} {    
  1571.     set listType ""
  1572.     foreach l [list UL OL DIR MENU] {
  1573.         set ex "<${l}(\[ \\t\\r\]+\[^>\]*>|>)"
  1574.         set listOpening [search -s -f 0 -i 1 -r 1 -m 0 -n $ex [getPos]]
  1575.         set ex2 </$l>
  1576.         set listClosing [search -s -f 0 -i 1 -r 1 -m 0 -n $ex2 [getPos]]
  1577.         # Search until a single list opening is found.
  1578.         while {[string length $listOpening] && [string length $listClosing] &&
  1579.         [lindex $listClosing 0] > [lindex $listOpening 0]} {
  1580.             set listOpening [search -s -f 0 -i 1 -r 1 -m 0 -n $ex [expr [lindex $listOpening 0] - 1]]
  1581.             set listClosing [search -s -f 0 -i 1 -r 1 -m 0 -n $ex2 [expr [lindex $listClosing 0] - 1]]
  1582.         }
  1583.         if {[string length $listOpening]} {
  1584.             lappend listType "$listOpening $l"
  1585.         }
  1586.     }
  1587.     set ltype [lindex [lindex $listType 0] 2]
  1588.     set lnum [lindex [lindex $listType 0] 0]
  1589.     for {set i 1} {$i < [llength $listType]} {incr i} {
  1590.         if {[lindex [lindex $listType $i] 0] > $lnum} {
  1591.             set ltype [lindex [lindex $listType $i] 2]
  1592.             set lnum [lindex [lindex $listType $i] 0]
  1593.         }
  1594.     }
  1595.     return $ltype
  1596. }
  1597.